Developer CD Series 1994 August: Tool Chest/Dev.CD Aug 94.toast/Tool Chest/Development Platforms/Macintosh Common Lisp Related/User Contributions/mapforms (code walker).sea/mapforms (code walker)/annotate.lisp

Text File | 1992-04-21 | 28.3 KB | 639 lines | [TEXT/CCL2]

;;; -*- Mode:LISP; Package:Language-Tools; Syntax:Common-Lisp -*-
;;;>>SHARED-MESSAGE
;;;>
;;;>******************************************************************************************
;;;>    This may only be used as permitted under the license agreement under
;;;>    which it has been distributed, and in no other way.
;;;>******************************************************************************************
;;;>
;;;>
;;; Written April 1983 by David A. Moon for use by the Common Lisp community
;;; based on a design by Alan Bawden

;;; Lisp code annotator
;;; Gathers information on the side-effects and environment dependencies of a form

;--- Common Lisp conversion issues:
;--- The function lists are completely implementation-dependent right now
;--- The function lists generally include everything in both ZL and CL global
;---   packages.  There are probably some SI things needed as well, and some
;---   ZL things that are never going to be called might be flushed (but why bother?)
;--- Review the function lists for recent CL changes!

;--- This could generate better code if it distinguished side-effects that cannot
;--- change variables from side-effects that can change variables.  Admittedly
;--- RPLACA could always change a variable, due to locatives to value cells,
;--- but consider the expansion of (SETF (GETF (AREF A I) B) C) which unnecessarily binds
;--- A and I to temporaries because it thinks that calling SET-GETF could change them.

;; The entry function to this module is ANNOTATE-FORM
;; The data structures defined on this page are also module interfaces
;; These are not exported, since they are only used by other tools

(EXPORT '(ANNOTATE-FORM *SIMPLE-VARIABLES*))
    ;--- Maybe the defstruct things should be exported, but for now I'm not
    ;--- going to, since probably user-written things shouldn't look at them

;; We deal with two kinds of variables:
;;  Substituted variables are those that we know the binding of.  We are
;;   considering substituting the binding for each usage of the variable.
;;   Only some callers of the annotator deal in substituted variables.
;;  Ordinary variables are all others.  We are only interested in these
;;   as a way of possibly partitioning side-effects.

;Nothing warms the heart like simple variables.
;These are ordinary variables that are known to be unaffected by side-effects;
;they are guaranteed not to be special, not to be setq'ed, not to be locf'ed,
;not to be forwarded, and not to be bound (causing name clashes).
;SETF binds this variable.
(DEFVAR *SIMPLE-VARIABLES* NIL)

;;; A Notepad is used to record information about the effects of executing
;;; some Lisp code, and the external influences that could affect it.

(DEFSTRUCT (NOTEPAD (:TYPE LIST) :CONC-NAME (:DEFAULT-POINTER NOTEPAD))
  (READ NIL)        ;Read operations (dependencies on the side-effects of others)
            ;This is a list of ordinary variables that have been read,
            ;or T if we might have depended on anything.
  (WRITTEN NIL)        ;Write operations (side-effects)
            ;This is a list of ordinary variables that have been written,
            ;or T if we might have changed anything.
  (SUBSTS NIL)        ;List of substituted variables we have seen used
  (CONTROL NIL))    ;Control-structure summary (lowest-priority first)
            ;NIL if we are guaranteed to get all the way to here
            ;COND if we aren't guaranteed to get all the way to here
            ;GO if conditional because of a non-local go or return
            ; This is different from COND because they aren't well-nested
            ;LOOP if we can get here more than once
            ;--- Note that we are distinctly careless about nested control
            ;structures.  Once having seen a loop we assume that everything
            ;after it is inside it, which isn't true.  Main issue for fixing
            ;this is getting the correct scoping of GO and RETURN.

;;; A Varnote is used to record information about the usage(s) of a substituted variable
(DEFSTRUCT (VARNOTE (:TYPE LIST) :CONC-NAME (:DEFAULT-POINTER VARNOTE))
  NAME            ;Variable name.  Must be first so ASSOC can be used.
  (N-USAGES 0)        ;(Static) number of times used
  (VARIABLE-ENV NIL)    ;All variables bound around usages of the variable
  (BLOCK-ENV NIL)    ;All block names extant around usages of the variable
  (TAG-ENV NIL)        ;All go tags extant around usages of the variable
  (NOTEPAD (MAKE-NOTEPAD)))    ;A notepad used to describe what has happened
                ; before the variable is used.  Set to NIL if we
                ; discover a reason this variable cannot be substituted.

;;; Operations on notepads

(DEFUN NOTE-VARIABLE-READ (NOTEPAD VAR)
  (LET ((READ (NOTEPAD-READ NOTEPAD)))
    (OR (EQ READ T)
    (MEMBER VAR READ)
    (SETF (NOTEPAD-READ NOTEPAD) (CONS VAR READ)))))

(DEFSUBST NOTE-ANY-READ (NOTEPAD)
  (SETF (NOTEPAD-READ NOTEPAD) T))

(DEFUN NOTE-VARIABLE-WRITTEN (NOTEPAD VAR)
  (LET ((WRITTEN (NOTEPAD-WRITTEN NOTEPAD)))
    (OR (EQ WRITTEN T)
    (MEMBER VAR WRITTEN)
    (SETF (NOTEPAD-WRITTEN NOTEPAD) (CONS VAR WRITTEN)))))

(DEFSUBST NOTE-ANY-WRITE (NOTEPAD)
  (SETF (NOTEPAD-WRITTEN NOTEPAD) T))

;True if the code fragments represented by two notepads are independent
;and hence may be executed in either order.  Maximally conservative
;in that arbitrary side-effects are assumed to affect all variables
;(we don't distinguish local variables that haven't been LOCF'ed).
(DEFUN DISJOINT-NOTES (X Y)
  (AND (DISJOINT-SETS (NOTEPAD-WRITTEN X) (NOTEPAD-WRITTEN Y))
       (DISJOINT-SETS (NOTEPAD-READ X) (NOTEPAD-WRITTEN Y))
       (DISJOINT-SETS (NOTEPAD-READ Y) (NOTEPAD-WRITTEN X))))

;True if two sets (of the type used in notepads) are disjoint
(DEFUN DISJOINT-SETS (X Y)
  (COND ((NULL X) T)
    ((NULL Y) T)
    ((EQ X T) NIL)
    ((EQ Y T) NIL)
    (T (LOOP FOR XX IN X NEVER (MEMBER XX Y)))))

;Union of two sets (of the type used in notepads)
(DEFUN JOIN-SETS (X Y)
  (COND ((NULL X) Y)
    ((NULL Y) X)
    ((EQ X T) X)
    ((EQ Y T) Y)
    (T (UNION X Y))))

;Make a copy of a notepad, initially containing the same information
(DEFSUBST FORK-NOTEPAD (NOTEPAD)
  (COPY-LIST NOTEPAD))

;Merge the information from JOINER into JOINEE
(DEFUN JOIN-NOTEPADS (JOINEE JOINER)
  (UNLESS (EQ JOINER JOINEE)    ;merely efficiency
    (SETF (NOTEPAD-READ JOINEE) (JOIN-SETS (NOTEPAD-READ JOINEE) (NOTEPAD-READ JOINER)))
    (SETF (NOTEPAD-WRITTEN JOINEE)
      (JOIN-SETS (NOTEPAD-WRITTEN JOINEE) (NOTEPAD-WRITTEN JOINER)))
    (SETF (NOTEPAD-SUBSTS JOINEE) (UNION (NOTEPAD-SUBSTS JOINEE) (NOTEPAD-SUBSTS JOINER)))
    (CASE (NOTEPAD-CONTROL JOINER)
      ((LOOP)
       (SETF (NOTEPAD-CONTROL JOINEE) 'LOOP))
      ((GO)
       (OR (EQ (NOTEPAD-CONTROL JOINEE) 'LOOP)
       (SETF (NOTEPAD-CONTROL JOINEE) 'GO)))
      ((COND)
       (OR (EQ (NOTEPAD-CONTROL JOINEE) 'LOOP)
       (EQ (NOTEPAD-CONTROL JOINEE) 'GO)
       (SETF (NOTEPAD-CONTROL JOINEE) 'COND))))))

;;; Conditional support

;Execute the body with the notepad indicating locally-conditional execution
;while being careful about the non-local-conditional and iteration flags
;Returns no particular value (-not- the value of the body)
(DEFMACRO ANNOTATE-CONDITIONAL (&BODY BODY)
  `(LET ((PREVIOUS-CONTROL (NOTEPAD-CONTROL)))
     (OR PREVIOUS-CONTROL
     (SETF (NOTEPAD-CONTROL) 'COND))
     ,@BODY
     (AND (NOT PREVIOUS-CONTROL)
      (EQ (NOTEPAD-CONTROL) 'COND)
      (SETF (NOTEPAD-CONTROL) NIL))
     NIL))

;;; Iteration support

(DEFVAR *IN-LOOP*)        ;NIL in normal once-through execution
                ;Inside a loop, this is the number of nested levels
(DEFVAR *LOOP-JOIN-QUEUE*)    ;Varnotes seen since the beginning of the loop
                ;These need to be joined with the notepad
                ;reflecting the full effects of the loop's body

;Normally fork a notepad, but if inside an iteration, don't bother
;as everything will be smushed back together at the end anyway
(DEFSUBST FORK-NOTEPAD-MAYBE (NOTEPAD)
  (IF *IN-LOOP* NOTEPAD (FORK-NOTEPAD NOTEPAD)))

;Called when an iteration is entered or exited.  When we get to the end of
;the loop, feed the notepad that comes out the end of the loop back into
;the beginning of the loop by joining it into any substitutable variables
;that were used inside the loop.  When there are nested loops, wait until
;we get to the end of the outermost one before really draining the queue.
(DEFUN ANNOTATE-ITERATION (ENTER-P)
  (LET ((NOTEPAD *MAPFORMS-STATE*))
    (COND (ENTER-P
       (SETQ *IN-LOOP* (1+ (OR *IN-LOOP* 0)))
       (SETF (NOTEPAD-CONTROL) 'LOOP))
      (T
       (WHEN (ZEROP (SETQ *IN-LOOP* (1- *IN-LOOP*)))
         (SETQ *IN-LOOP* NIL)
         (DOLIST (VARNOTE *LOOP-JOIN-QUEUE*)
           (IF (VARNOTE-NOTEPAD)
           (JOIN-NOTEPADS (VARNOTE-NOTEPAD) NOTEPAD)))
         (SETQ *LOOP-JOIN-QUEUE* NIL))))))


;;; Variables bound by ANNOTATE-FORM

(DEFVAR *SUBST-ALIST*)    ;List of varnotes for all the substituted variables of interest

(DEFVAR *FREE-VARIABLES*)    ;Collect lexically-scoped names used freely
(DEFVAR *FREE-BLOCKS*)        ;..
(DEFVAR *FREE-TAGS*)        ;..
(DEFVAR *REPLICABILITY*)    ;Accumulates return value from ANNOTATE-FORM

;;; Main function

;Given a form, return a notepad for it, and optionally annotate some
;substitutable variables as well.
;In addition to the notepad, we return the sets of lexically-scoped names used freely,
;and the "replicability" of the form, which is the number of times
;it is worth evaluating it before binding a variable to it (this is 1
;if this is any form that can't be evaluated multiple times and get
;the same result as evaluating it once).
;The free variables don't include the substituted variables.
;Note: the use of the MAPFORMS state variable herein is unusual, because the
;value of the variable doesn't change.  Instead it is a structure and we change its fields.
(DEFUN ANNOTATE-FORM (FORM &OPTIONAL (*SUBST-ALIST* NIL))
  (DECLARE (VALUES NOTEPAD FREE-VARIABLES FREE-BLOCKS FREE-TAGS REPLICABILITY))
  (LET ((*IN-LOOP* NIL)
    (*LOOP-JOIN-QUEUE* NIL)
    (*FREE-VARIABLES* NIL)
    (*FREE-BLOCKS* NIL)
    (*FREE-TAGS* NIL)
    (*REPLICABILITY* 1000000))    ;initially "infinity"
    (VALUES (MAPFORMS #'ANNOTATE-FORM-INTERNAL FORM
              :INITIAL-STATE (MAKE-NOTEPAD)
              :BOUND-VARIABLES NIL
              :APPLY-FUNCTION #'ANNOTATE-FORM-AFTER-ARGS
              :ITERATION-HOOK #'ANNOTATE-ITERATION)
        *FREE-VARIABLES*
        *FREE-BLOCKS*
        *FREE-TAGS*
        *REPLICABILITY*)))

(DEFUN ANNOTATE-FORM-INTERNAL (FORM KIND USAGE NOTEPAD &AUX VARNOTE (BYPASS NIL))
  (CASE KIND
    (SYMEVAL
      (COND ((MEMBER FORM *MAPFORMS-BOUND-VARIABLES*))
             ;Uninteresting if variable bound inside form being analyzed
        ((SETQ VARNOTE (ASSOC FORM *SUBST-ALIST*))
             ;Accessing a substitutable variable: remember circumstances
         (INCF (VARNOTE-N-USAGES))
         (SETF (VARNOTE-VARIABLE-ENV)
           (UNION (VARNOTE-VARIABLE-ENV) *MAPFORMS-BOUND-VARIABLES*))
         (SETF (VARNOTE-BLOCK-ENV) (UNION (VARNOTE-BLOCK-ENV) *MAPFORMS-BLOCK-NAMES*))
         (SETF (VARNOTE-TAG-ENV) (UNION (VARNOTE-TAG-ENV) *MAPFORMS-GO-TAGS*))
         ;; If in a loop, defer the join until we know everything about the
         ;; loop, since what goes around, comes around
         (COND (*IN-LOOP*
            (PUSHNEW VARNOTE *LOOP-JOIN-QUEUE*))
           ((VARNOTE-NOTEPAD)
            (JOIN-NOTEPADS (VARNOTE-NOTEPAD) NOTEPAD)))
         ;; Remember that we passed by a usage of this variable
         (PUSHNEW FORM (NOTEPAD-SUBSTS)))
            ;Accessing a simple variable: not to be kept track of
        ((MEMBER FORM *SIMPLE-VARIABLES*))
        (T        ;Accessing a free variable
         (PUSHNEW FORM *FREE-VARIABLES*)
         (NOTE-VARIABLE-READ NOTEPAD FORM))))

    (SET
      (SETQ *REPLICABILITY* 1)        ;Never do this multiple times
      (COND ((MEMBER FORM *MAPFORMS-BOUND-VARIABLES*))
            ;Uninteresting if variable bound inside form being analyzed
        ((SETQ VARNOTE (ASSOC FORM *SUBST-ALIST*))
            ;Setting a substitutable variable makes it unsubstitutable
         (SETF (VARNOTE-NOTEPAD) NIL))
        (T        ;Setting a free variable
         (PUSHNEW FORM *FREE-VARIABLES*)
         (NOTE-VARIABLE-WRITTEN NOTEPAD FORM))))

    (GO
      (SETQ *REPLICABILITY* 1)        ;Never do this multiple times
      (SETF (NOTEPAD-CONTROL) 'GO)    ;Non-local control sequencing has been seen
      (UNLESS (MEMBER FORM *MAPFORMS-GO-TAGS*)
    ;; GO outside of the form being analyzed is a side-effect
    (NOTE-ANY-WRITE NOTEPAD)
    ;; and furthermore is an environmental dependency
    (PUSHNEW FORM *FREE-TAGS*)))

    (RETURN-FROM
      (SETQ *REPLICABILITY* 1)        ;Never do this multiple times
      (SETF (NOTEPAD-CONTROL) 'GO)    ;Non-local control sequencing has been seen
      (UNLESS (IF (NULL FORM)        ;Zetalisp version of unnamed RETURN
          (NOT (NULL *MAPFORMS-BLOCK-NAMES*))
          (MEMBER FORM *MAPFORMS-BLOCK-NAMES*))
    ;; RETURN outside of the form being analyzed is a side-effect
    (NOTE-ANY-WRITE NOTEPAD)
    (PUSHNEW FORM *FREE-BLOCKS*)))

    (ARBITRARY
      (SETQ *REPLICABILITY* 1)        ;Never do this multiple times
      (NOTE-ANY-WRITE NOTEPAD))

    ((QUOTE LET DECLARE))        ;Uninteresting to us

    (OTHERWISE        ;Function combination or special form
      (COND ((NOT (OR (NULL KIND) (LISTP KIND)))
         (ERROR "~S unrecognized KIND symbol" KIND))
        ((SETQ BYPASS (AND (SYMBOLP (CAR FORM))
                   (GET (CAR FORM) 'ANNOTATE)))
         (FUNCALL BYPASS FORM USAGE NOTEPAD))
        ((NULL KIND))            ;Function combination
        ((AND (LISTP (CDR KIND)) (EQ (CADR KIND) 'COND))
            ;Special forms that we must understand in detail
            ;(just conditionals now)
         (ERROR "The ~A-type special form ~S does not have an ANNOTATE handler"
            (CADR KIND) (CAR FORM)))
        (T NIL))))    ;Special forms that MAPFORMS will analyze, no effects in or out (yet)

  (VALUES NOTEPAD BYPASS))

;Called after analyzing the arguments of a function, the arguments
;and body of a lambda-combination, or all the subforms of a special form.
;For a function combination, make our conservative estimate of the effects
;of running the function, assuming the primitive functions we know about
;are not redefined by the user to be something else.
(DEFUN ANNOTATE-FORM-AFTER-ARGS (FORM KIND IGNORE NOTEPAD)
  (AND (NULL KIND)            ;Function combination
       (SYMBOLP (CAR FORM))        ;and not a LAMBDA
       (MULTIPLE-VALUE-BIND (CLASS REPLICABILITY)
       (FUNCTION-ANNOTATION-CLASS (CAR FORM))
     (COND ((EQ REPLICABILITY 'TWO-TIMES)
        (SETQ *REPLICABILITY*
              (IF (> *REPLICABILITY* 2)
              2        ;This thing could be done twice
              1)))        ;But two of them should only be done once
           ((NULL REPLICABILITY)    ;Don't know, do it only once
        (SETQ *REPLICABILITY* 1)))
     (CASE CLASS
       (SIMPLE )            ;No side-effects in or out
       (READER            ;Depends on environment but doesn't change anything
        (NOTE-ANY-READ NOTEPAD))
       (OTHERWISE            ;Default is to assume that it could do anything
        (NOTE-ANY-WRITE NOTEPAD)))))
  NOTEPAD)

;;; Procedural knowledge of conditional and iteration special forms

; Note that these functions will freely cdr off the end of the form when
; that makes no difference to the ultimate result, to simplify the coding.

(DEFPROP AND AND-OR-ANNOTATE ANNOTATE)
(DEFPROP OR AND-OR-ANNOTATE ANNOTATE)
(DEFUN AND-OR-ANNOTATE (FORM IGNORE NOTEPAD)
  (MAPFORMS-1 (CADR FORM))        ;First clause executed unconditionally
  (ANNOTATE-CONDITIONAL            ;Everything after this is conditional
    (ANNOTATE-FORMS (CDDR FORM))))

;The hair in COND is primarily that the consequents of one clause
;neither preceed nor follow the consequents of another, while the antecedents
;follow each other.  Thus we must split the notepad into multiple independent pads.
(DEFUN (:PROPERTY COND ANNOTATE) (FORM IGNORE NOTEPAD)
  (MAPFORMS-1 (CAADR FORM))        ;First antecedent executed unconditionally
  (ANNOTATE-CONDITIONAL            ;Everything after this is conditional
    (LOOP FOR (ANTE . CONSE) IN (CDR FORM)    ;Iterate over clauses
      WITH SPLITS = NIL        ;Collect split-off notepads for consequents
      AS FIRST-CLAUSE = T THEN NIL DO
      (OR FIRST-CLAUSE
      (MAPFORMS-1 ANTE))        ;Do antecedent if not done already
      (UNLESS (NULL CONSE)        ;Do consequents with a separate notepad
    (LET ((SPLIT (FORK-NOTEPAD-MAYBE NOTEPAD)))
      (PUSH SPLIT SPLITS)
      (ANNOTATE-SPLIT-FORMS CONSE SPLIT)))
      FINALLY                ;Merge all the consequents consequences
        (DOLIST (SPLIT SPLITS)
      (JOIN-NOTEPADS NOTEPAD SPLIT)))))

;IF is just a simpler version of COND
(DEFUN (:PROPERTY IF ANNOTATE) (FORM IGNORE NOTEPAD)
  (MAPFORMS-1 (CADR FORM) 'TEST)    ;The test is executed unconditionally
  (ANNOTATE-CONDITIONAL
    (IF (NULL (CDDDR FORM))        ;Check for 1-arm case (merely efficiency)
    (MAPFORMS-1 (CADDR FORM))
    (LET ((SPLIT (FORK-NOTEPAD-MAYBE NOTEPAD)))
      (MAPFORMS-1 (CADDR FORM))
      (ANNOTATE-SPLIT-FORMS (CDDDR FORM) SPLIT)
      (JOIN-NOTEPADS NOTEPAD SPLIT)))))

;Annotate a list of forms, being careless about the USAGE
;Fix this if we ever start depending on USAGE (will need to add more args)
(DEFUN ANNOTATE-FORMS (LIST)
  (DOLIST (FORM LIST)
    (MAPFORMS-1 FORM)))

;Annotate a list of forms with a different notepad, being careless about the USAGE
(DEFUN ANNOTATE-SPLIT-FORMS (LIST NOTEPAD)
  (LET ((*MAPFORMS-STATE* NOTEPAD))
    (DOLIST (FORM LIST)
      (MAPFORMS-1 FORM))))

;;; Knowledge about various functions (not special forms)

;; We have a little bit of knowledge of the primitive functions of the
;; language:

;; Notice that we know nothing about any function that has any side effects.
;; This is because all functions with side effects are equally uncontrolled.
;; There is no point in going through the exercize of dividing them up into
;; classes according to who can effect whom on a machine where RPLACA can be
;; used to store into a local variable, or into an array...

;; Notice that both classes of functions (simple and reader) have the
;; property that it is always safe to not call them at all if it turns
;; out that they are being called for effect.

;; The attributes of a function are recorded in a bit mask on the
;; FUNCTION-ATTRIBUTES property of the name of the function.
;; The default attributes for things we don't know about have none of these
;; bits set, which means that they may have arbitrary side-effects, may
;; depend on anything in the environment, and may be arbitrarily expensive to compute.
;; This bit mask used to be defined with a :FIXNUM defstruct, but Common
;; Lisp doesn't have such features, so do it by hand.

(DEFCONSTANT MANY-TIMES-ATTRIBUTE 1)    ;cheaper to compute than to bind a variable
(DEFCONSTANT TWO-TIMES-ATTRIBUTE 2)    ;worth computing twice before binding a variable
(DEFCONSTANT SIMPLE-ATTRIBUTE 4)    ;neither affects nor depends on the environment
(DEFCONSTANT REDUCIBLE-ATTRIBUTE #o10)    ;SIMPLE and may be constant-folded (single-valued)
(DEFCONSTANT READER-ATTRIBUTE #o20)    ;depends on the environment but doesn't change it

(DEFPARAMETER INTENTIONALLY-UNDEFINED-FUNCTIONS        ;Suppress warning for these
      #+LISPM ())

(DEFMACRO PUT-ATTRIBUTES (F &REST ATTRIBUTES)
  `(PROGN
     (UNLESS (FBOUNDP ,F)
       (UNLESS (MEMBER ,F INTENTIONALLY-UNDEFINED-FUNCTIONS)
     (WARN "PUT-ATTRIBUTES of ~S, which is not a defined function; may be a typo." ,F)))
     (SETF (GET ,F 'FUNCTION-ATTRIBUTES)
       (LOGIOR (GET ,F 'FUNCTION-ATTRIBUTES 0)
           ,@(MAPCAR #'(LAMBDA (NAME) (INTERN (STRING-APPEND NAME "-ATTRIBUTE")
                              "LANGUAGE-TOOLS"))
                 ATTRIBUTES)))))

;The first value is:
; SIMPLE - neither affects nor depends on the environment
; READER - depends on the environment but doesn't change it
; WRITER - may change the environment (and may also depend on it)
;The second value is:
; NIL - expensive to compute
; TWO-TIMES - worth computing twice rather than binding a variable
; MANY-TIMES - worth computing any number of times rather than binding a variable
(DEFUN FUNCTION-ANNOTATION-CLASS (FUNCTION)
  (IF (SYMBOLP FUNCTION)
      (LET ((ATTRIBUTES (GET FUNCTION 'FUNCTION-ATTRIBUTES 0)))
    (VALUES (COND ((LOGTEST SIMPLE-ATTRIBUTE ATTRIBUTES) 'SIMPLE)
              ((LOGTEST READER-ATTRIBUTE ATTRIBUTES) 'READER)
              (T 'WRITER))
        (COND ((LOGTEST MANY-TIMES-ATTRIBUTE ATTRIBUTES) 'MANY-TIMES)
              ((LOGTEST TWO-TIMES-ATTRIBUTE ATTRIBUTES) 'TWO-TIMES))))
      'WRITER))

;;; Store the function attributes

;These are compiled functions so they will run fast.  They are only called once
(DEFUN ATTR-SIMPLE-REDUCIBLE (FNS)
  (DOLIST (F FNS)
    (PUT-ATTRIBUTES F SIMPLE REDUCIBLE)))

(DEFUN ATTR-SIMPLE (FNS)
  (DOLIST (F FNS)
    (PUT-ATTRIBUTES F SIMPLE)))

(DEFUN ATTR-READER (FNS)
  (DOLIST (F FNS)
    (PUT-ATTRIBUTES F READER)))

(DEFUN ATTR-MANY-TIMES (FNS)
  (DOLIST (F FNS)
    (PUT-ATTRIBUTES F MANY-TIMES)))

(DEFUN ATTR-TWO-TIMES (FNS)
  (DOLIST (F FNS)
    (PUT-ATTRIBUTES F TWO-TIMES)))

;; Simple functions are totally uneffected by side effects.  Note that anything
;; that conses is liable to be sensitive to the default-cons-area, so isn't
;; included here (consing of bignums/flonums excepted).
;; Reducible functions have the further property that they only return one value
;; and anything else (if anything) needed to ensure that an expression made up
;; of nothing but reducible functions and constants might as well be run at
;; compile time.

;; The simple and reducible functions
(ATTR-SIMPLE-REDUCIBLE
       '(   * + - / 1+ 1- /= < <= = > >=
         ZL:/ ZL:\\ ZL:\\\\ ZL:^   ;probably some macros expand into these
         ABS ACOS ACOSH ZL:ADD1 ALPHA-CHAR-P ALPHANUMERICP
         ARRAYP ZL:ASCII ASH ASIN ASINH ATAN ATANH ZL:ATAN ZL:ATAN2 ATOM
         ZL:BIGP BIT-VECTOR-P BOOLE BOTH-CASE-P BYTE-POSITION BYTE-SIZE BYTE
         CEILING CHARACTERP
         CHAR-BIT CHAR-BITS CHAR-CODE CHAR-DOWNCASE CHAR-EQUAL CHAR-FONT
         CHAR-GREATERP CHAR-INT CHAR-LESSP CHAR-NAME CHAR-NOT-EQUAL CHAR-NOT-GREATERP
         CHAR-NOT-LESSP CHAR-UPCASE
         CHAR/= CHAR<= CHAR< CHAR= CHAR>= CHAR> CHAR CHAR CHAR
         CIS ZL:CLOSUREP CODE-CHAR COMMONP COMPILED-FUNCTION-P
         COMPLEXP CONJUGATE CONSP CONSTANTP COS COSD COSH
         ZL:DATA-TYPE DENOMINATOR ZL:DEPOSIT-BYTE DEPOSIT-FIELD ZL:DIFFERENCE DPB
         DYNAMIC-CLOSURE-P
         EQ EQL ERRORP EVENP EXP EXPT
         FALSE FCEILING FFLOOR ZL:FIX ZL:FIXR ZL:FIXP FLOAT FLOATP FLOOR
         ZL:FLONUMP FROUND FTRUNCATE FUNCTIONP
         GCD ZL:GET-PNAME ZL:GETCHAR ZL:GETCHARN ZL:GREATERP GRAPHIC-CHAR-P
         ZL:HAIPART ZL:HAULONG HASH-TABLE-P
         IDENTITY IMAGPART INT-CHAR INTEGERP INTEGER-LENGTH IGNORE ISQRT
         KEYWORDP
         LCM LDB LDB-TEST ZL:LESSP LEXICAL-CLOSURE-P LISTP ZL:LOAD-BYTE ZL:LOCATIVEP
         LOG LOGAND LOGANDC1 LOGANDC2 LOGBITP LOGCOUNT LOGEQV LOGIOR LOGNAND LOGNOR
         LOGNOT LOGORC1 LOGORC2 LOGTEST LOGXOR LOWER-CASE-P LSH
         MAKE-CHAR MASK-FIELD MAX MIN ZL:MINUS MINUSP MOD
         NAME-CHAR NLISTP NOT NSYMBOLP NULL NUMBERP NUMERATOR
         ODDP
         PATHNAMEP PHASE ZL:PLUS PLUSP
         ZL:QUOTIENT
         RANDOM-STATE-P RATIONALP READTABLEP REALPART REM REMAINDER ROT ROUND
         SAMEPNAMEP SET-CHAR-BIT SIGNUM SIN SIND SINH
         #+CADR SMALL-FLOAT #+CADR SMALL-FLOATP
         SQRT STANDARD-CHAR-P STREAMP STRING-CHAR-P STRINGP ZL:SUB1 ZL:SUBRP SYMBOLP
         TAN TANH TIME-DIFFERENCE TIME-INCREMENT TIME-LESSP ZL:TIMES TRUE TYPEP
         UPPER-CASE-P VECTORP
         ZEROP))

;; The simple but not reducible functions
(ATTR-SIMPLE '(VALUES VALUES-LIST))

;; Reader functions do not have side effects, but they are potentially
;; sensitive to them.  Functions that create locatives are here because it's not
;; clear that you can't get a different locative (not EQ) if someone performs
;; some structure-fowarding.  Any function that takes a functional argument
;; (like FUNCALL, MAPCAR or ASS) should not be here since the properties of the
;; function are unknown.  I/O operations are side effects.  So is asking what
;; time it is (the TIME function).  When in doubt, leave it out!
;; The reason it works for consing functions to be here is that they do not
;; have the TWO-TIMES and MANY-TIMES attributes, so calls to them will not
;; be replicated, just shuffled around.  And it is considered okay to
;; remove consing during optimization.  Consing functions are not SIMPLE
;; because of the variable DEFAULT-CONS-AREA.

(ATTR-READER
       '(ACONS ADJOIN ALOC
         ALPHALESSP  ;because of ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON
         ZL:AP-1 ZL:AP-2 #+CADR ZL:AP-3 ZL:AP-LEADER
         APPEND ZL:AR-1 ZL:AR-2 #+CADR ZL:AR-3 AREF ZL:ARG ARGLIST
         ARGS-INFO ZL:ARRAY-#-DIMS ZL:ARRAY-ACTIVE-LENGTH ZL:ARRAY-DIMENSION-N
         ARRAY-DIMENSIONS ARRAY-DISPLACED-P ARRAY-ELEMENT-SIZE ARRAY-HAS-LEADER-P
         ARRAY-IN-BOUNDS-P ARRAY-INDEXED-P ARRAY-INDIRECT-P ARRAY-LEADER
         ARRAY-LEADER-LENGTH ZL:ARRAY-LENGTH ARRAY-TYPE ZL:ARRAYDIMS
         ASSOC ASSOC-IF ASSOC-IF-NOT ASSQ
         BIT BOUNDP BUTLAST
         CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR
         CADDAR CADDDR CADDR CADR CAR ZL:CAR-LOCATION CDAAAR CDAADR CDAAR
         CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR CDDDR
         CDDR CDR CHAR CHARACTER CIRCULAR-LIST CLOSURE CLOSURE-ALIST CLOSURE-FUNCTION
         CLOSURE-VARIABLES CONS COPY-ALIST COPY-LIST COPY-LIST* COPY-READTABLE
         COPY-SEQ COPY-SYMBOL COPY-TREE COUNT COUNT-IF COUNT-IF-NOT
         DEBUGGING-INFO DOCUMENTATION
         EIGHTH ELT EQUAL EQUALP ZL:EXPLODE ZL:EXPLODEC ZL:EXPLODEN
         FBOUNDP FDEFINEDP FDEFINITION FIFTH
         FIND FIND-IF FIND-IF-NOT ZL:FIND-POSITION-IN-LIST ZL:FIND-POSITION-IN-LIST-EQUAL
         FIRST ZL:FIRSTN ZL:FLATC ZL:FLATSIZE FLAVOR-ALLOWS-INIT-KEYWORD-P
         FOURTH ZL:FSYMEVAL ZL:FUNCTION-CELL-LOCATION
         G-L-P GET ZL:GET GETF GET-HANDLER-FOR GET-PROPERTIES GETHASH ZL:GETL
         INTERSECTION
         LAST LDIFF LENGTH LIST LIST-ARRAY-LEADER LIST-LENGTH LIST*
         ZL:LISTARRAY ZL:LISTIFY LOCATE-IN-CLOSURE LOCATE-IN-INSTANCE
         MAKE-ARRAY MAKE-BROADCAST-STREAM MAKE-CONCATENATED-STREAM MAKE-ECHO-STREAM
         ZL:MAKE-EQUAL-HASH-TABLE MAKE-HASH-TABLE MAKE-LIST MAKE-PLANE
         MAKE-RANDOM-STATE MAKE-SEQUENCE MAKE-STRING MAKE-STRING-INPUT-STREAM
         MAKE-STRING-OUTPUT-STREAM MAKE-SYMBOL MAKE-SYNONYM-STREAM MAKE-TWO-WAY-STREAM
         MEMBER MEMBER-IF MEMBER-IF-NOT MEMQ
         NAMED-STRUCTURE-P NAMED-STRUCTURE-SYMBOL NCONS NINTH NLEFT NTH NTHCDR
         ZL:PACKAGE-CELL-LOCATION PAIRLIS PKG-FIND-PACKAGE ZL:PLIST
         POSITION POSITION-IF POSITION-IF-NOT ZL:PROPERTY-CELL-LOCATION
         RASSOC RASSOC-IF RASSOC-IF-NOT ZL:RASSQ REMOVE REMOVE-IF REMOVE-IF-NOT REMQ
         REST REVERSE
         SBIT SCHAR SEARCH SECOND SEVENTH SIXTH STREAM-ELEMENT-TYPE
        ;String ops are readers because you can side-effect chars of a string
         STRING STRING-APPEND STRING-CAPITALIZE
         STRING-COMPARE STRING-DOWNCASE STRING-EQUAL STRING-GREATERP
         STRING-LEFT-TRIM STRING-LENGTH STRING-LESSP STRING-NOT-EQUAL
         STRING-NOT-GREATERP STRING-NOT-LESSP STRING-PLURALIZE
         ZL:STRING-REVERSE ZL:STRING-REVERSE-SEARCH ZL:STRING-REVERSE-SEARCH-CHAR
         ZL:STRING-REVERSE-SEARCH-NOT-CHAR ZL:STRING-REVERSE-SEARCH-NOT-SET
         ZL:STRING-REVERSE-SEARCH-SET STRING-RIGHT-TRIM STRING-SEARCH
         STRING-SEARCH-CHAR STRING-SEARCH-NOT-CHAR STRING-SEARCH-NOT-SET STRING-SEARCH-SET
         STRING-TRIM STRING-UPCASE STRING/= STRING<= STRING< STRING= STRING>= STRING>
         SUBLIS SUBST SUBST-IF SUBST-IF-NOT SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
         SUBSTRING SVREF SXHASH SYMBOL-FUNCTION SYMBOL-NAME SYMBOL-PACKAGE SYMBOL-PLIST
         SYMBOL-VALUE-IN-CLOSURE SYMBOL-VALUE-IN-INSTANCE
         ZL:SYMEVAL ZL:SYMEVAL-IN-CLOSURE ZL:SYMEVAL-IN-INSTANCE
         TAILP TENTH THIRD TREE-EQUAL
         UNION
         VALUE-CELL-LOCATION
         XCONS))

;; These functions have the property that is is always cheaper to recompute
;; them rather that binding a variable the their value.  That is,
;;  (let ((x (car y))) <exp>) will be more expensive than simply replacing
;; every occurence of x by (car y) in <exp>.
;; NOT, NULL, ATOM, ENDP, and LISTP are in this list because of the assumption that they
;; are most likely being used as predicates rather than for value, and therefore
;; will disappear into branch instructions rather than generating extra code.
;; Note that on the 3600 variable-binding is cheaper relative to CAR/CDR

#+CADR
(ATTR-MANY-TIMES '(CAAR CADR CAR CDAR CDDR CDR))

(ATTR-MANY-TIMES '(ATOM ENDP FALSE LISTP NLISTP NOT NULL TRUE))

;; Similar to the above, it has been determined that these single argument
;; functions (all MISC instructions) can be substituted into a body UP TO two
;; times, beyond that it is better to have the local variable.
;; On the 3600, this list is empty since variable-binding is almost free
;; and some of these operations are actually more expensive (not microcoded)

#+CADR
(ATTR-TWO-TIMES
       '(1+ ZL:1+$ 1- ZL:1-$
         ABS ZL:ADD1 ZL:ARRAY-ACTIVE-LENGTH ARRAY-HAS-LEADER-P ZL:ARRAY-LENGTH ARRAYP
         BOUNDP
         CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CADAAR CADADR CADAR CADDAR
         CADDDR CADDR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDDAAR CDDADR
         CDDAR CDDDAR CDDDDR CDDDR
         EVENP
         FBOUNDP ZL:FIX ZL:FIXP FLOAT FLOATP ZL:FSYMEVAL
         G-L-P ZL:GET-PNAME
         ZL:HAULONG
         ZL:MINUS            ;- of one argument should be treated specially?
         MINUSP
         NSYMBOLP NUMBERP
         ODDP
         PLUSP
         SMALL-FLOAT STRINGP ZL:SUB1 SYMBOLP
         SYMBOL-FUNCTION SYMBOL-PRINT-NAME SYMBOL-VALUE
         ZL:SYMEVAL
         ZEROP))